perm filename PT2.3[MSS,LCS] blob
sn#238787 filedate 1976-10-05 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SUBROUTINE PT2
C00019 ENDMK
C⊗;
SUBROUTINE PT2
INTEGER VALID
DIMENSION VALID(6),NBAR(36)
DATA QLINE/140.0/,HX/2./,VALID/1,4,8,2,3,-2/,SLSP/11.0/
C QLINE=BASIC LINE LENGTH, HX=HEIGHT MULTIPLIER, ZL=LN. LNGTH FACTOR.
C ADD MORE TO VALID LATER *****
COMMON /SF/KL,RT,KP,STFSZ,NAMX /IPG/IPG,JPG,BRACK,
1 RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(-3/4)
COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
COMMON/STF/RSTFAC(-3/4),RSTJ2 /IVV/IV(1)
COMMON /POSI/STFF(-3/4),JJ2,JPQ /LLL/L,LL,I,RXQ
1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1)
EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
1,(R8,RQ(6)),(R9,RQ(7)),(LCNT,IV(80)),(NDPY,IV(81))
CC 1,(RSTF,RSTFAC(100))
C TRNSP'S Bb, F, BBb, A, G, Eb.
NAMQ='AAAAA'
LL=0
NBAR(1)=0
5 FORMAT(F,2I)
IF(RS.NE.'OLD')GO TO 2000
CALL GETFIL('PARTS')
CALL FASTIN(RSTFAC,128)
CALL FASTIN(KPN,JJ2)
CALL FASTIN(Q,JPQ)
2000 TYPE 144
144 FORMAT(' STAFF SIZE, TRANSP. '$)
ACCEPT 5,RSTJ2,LL
IF(MOD(LL,7).EQ.0)GO TO 140
DO 40 L=1,6
40 IF(LL.EQ.VALID(L))GO TO 140
TYPE 240
GO TO 2000
240 FORMAT(' THIS TRANSP NOT OFFERED')
140 IF(IPG)GO TO 41
IF(RSTJ2.EQ.0)GO TO 41
RA=RSTJ2/RPSZ(1)
DO 141 K=1,JPG
141 RPSZ(K)=RPSZ(K)*RA
41 IF(RSTJ2.EQ.0)RSTJ2=.9
L=JJ2-2
TR=LL
IF(LL.NE.0)CALL TRNSP(L,TR)
I=L
KK=1
C FOUND A BAR LINE
ENDLN=ENDL(JJ)
C FUNCTION ENDL(JJ) (IN FAIL) DOES ALL ABOVE
NA=1000
N=0
TYPE 90,JJ
RA=0
90 FORMAT(' NUMBER OF BARS PER LINE: TOTAL BAR LINES='I3/)
ZLINE=QLINE
9 KL=0
XLINE=ZLINE
J=0
LL=0
DO 8 K=1,JJ
IF(RN(K).LT.XLINE)GO TO 8
KP=K-KL
C NUMBER OF BARS, THIS LINE
CC TYPE 89,KP
KL=K
J=J+1
IF(IV(J).NE.KP)LL=-1
IV(J)=KP
XLINE=RN(K)+ZLINE
IF(ENDLN-XLINE.LT.80.)XLINE=ENDLN
8 CONTINUE
IF(LL)TYPE 108,RA,(IV(K),K=1,J)
IF(RT)GO TO 105
108 FORMAT(F6.2,8(3I3,1X))
CC TYPE 108
CC108 FORMAT(/)
CC89 FORMAT('+',I3,$)
IF(J.GT.NA)GO TO 107
IF(N.EQ.0)GO TO 105
C SKIP IF FIRST TIME
IF(N.NE.KP)GO TO 106
IF(J.EQ.NA)GO TO 105
106 RT=.05
C SHRINK OR EXPAND?
RA=RA+RT
ZLINE=QLINE*RS/RA
GO TO 9
1107 TYPE 111,KA
107 FORMAT(' CAN''T DO IT!')
TYPE 107
105 TYPE 104,J
104 FORMAT(I4,' LINES - OR TYPE N1, N2 --'$)
KA=0
ACCEPT 5,RA,N,KL
C TYPE 0,n TO EXIT WITH n SPACING BETWEEN STAVES (2 IS DEFAULT)
IF(KL.NE.0)GO TO 110
C FOR SPECIFICATION OF HOW MANY BARS ON EACH LINE
C NO MORE THAN 36 NUMS, INCLUDING 0S (FOR PAGE MARKS)
IF(RA.EQ.0)GO TO 11
IF(ZLINE.EQ.QLINE)RS=J
NA=RA
RT=NA-RA
IF(RT)GO TO 109
RA=RA-.6
C CHECK THIS ↑↑↑ NUMBER!
IF(N.EQ.0)GO TO 90
109 ZLINE=QLINE*RS/RA
GO TO 9
111 FORMAT(36I)
110 REREAD 111,NBAR
911 DO 112 K=36,1,-1
KP=NBAR(K)
KA=KA+KP
112 IF(KP.EQ.0.AND.KA.EQ.0)KL=K
IF(KA.NE.JJ)GO TO 1107
C MISMATCH!
N=26-2*MOD(KL-1,12)
IF(N.EQ.26)N=0
C TO SPACE OUT STAVES VERTICALLY
11 RA=0
IF(IPG)GO TO 811
IF(NBAR(1).NE.0)GO TO 811
DO 711 K=1,36
IF(K.GT.J)IV(K)=0
711 NBAR(K)=IV(K)
GO TO 911
811 JEND=-1
XLINE=ZLINE
CLEF=-99
JSLUR=0
LC=1
SIG=CLEF
HX=2
SP=2.45
C DEFAULT VERT. SPACE UNITS
IF(N.EQ.0)GO TO 100
C SPACED OUT DEPENDING ON NUM OF LINES
HX=N
RSTFAC(96)=0
C MUST BE 0 IN MS TO MAKE DISPLAY
SP=SP+(HX-2.)*.11
100 KL=1
IF(JEND.EQ.0)GO TO 1000
103 FORMAT(' TYPE OUTPUT FILE NAME ',$)
102 FORMAT(A5)
TYPE 103
ACCEPT 102,NAMX
IF(NAMX.EQ.' ')NAMX=NAMQ
NAMZ=NAMX
NPG=1
RA=JPG*RSTJ2
MPG=10./RA
C MPG=NUM OF BRACES PER PAGE.
SPG=10./MPG
C SPG IS SPACE TO BE SET ABOVE STAFF 0
IF(LOOKF(NAMX).GE.0)GO TO 88
TYPE 88,NAMX
ACCEPT 102,L
IF(L.EQ.'N')GO TO 103
88 FORMAT(' WRITE OVER FILE ',A5,'???? '$)
1000 KP=1
JEND=0
C FLAG FOR PAGE END - WHEN -1
RT=2
J=KK
HGT=HX*2.
LB=0
MTR1=-1
DO 1 K=KK,I
N=KPN(K)
IF(Q(N+1).NE.4)GO TO 1
IF(KA.EQ.0)GO TO 334
LB=LB+1
C BAR COUNTER
IF(NBAR(LC).GT.LB)GO TO 1
C FOR SPECIFIED BARS
LC=LC+1
LB=0
IF(NBAR(LC).NE.0)GO TO 335
JEND=-1
LC=LC+1
GO TO 335
334 IF(Q(N+3).LT.XLINE)GO TO 1
C FOUND LAST BAR LINE.
335 RX=0
MTR1=-1
MTR2=-1
LL=KPN(K+1)
C TO ADD METER AT END OF BAR
RS=Q(LL+1)
IF(RS.LE.4)GO TO 3
IF(RS.EQ.18)MTR1=LL
C WHAT ABOUT REHRSL NUMS, ETC??
LL=KPN(K+2)
RS=Q(LL+1)
IF(RS.LE.4)GO TO 3
IF(IPG)GO TO 4011
IF(Q(LL+2).NE.Q(N+2))GO TO 4111
4011 IF(RS.EQ.18)MTR2=LL
LL=KPN(K+3)
IF(IPG)GO TO 4211
IF(Q(LL+2).NE.Q(N+2))GO TO 4111
4211 IF(Q(LL+1).EQ.18)MTR2=LL
4111 IF(MTR1.GT.0)GO TO 3
MTR1=MTR2
MTR2=-1
C IN CASE IT SAW SOMETHING AHEAD OF NEW METER
3 JJ=KP
C PUTS IN STAFF
RS=3.
IF(RT.NE.0)GO TO 331
C NEXT FOR BOTTOM STAFF. PUTS IN SPACER.
RS=6.
331 IF(IPG)GO TO 411
HX=8
RZ=0
RX=RT
DO 611 JP=1,JPG
RT=RSTNUM(JP)
RS=3
C WD CNT IS RS, HX IS CODE(8), ARRAYS AND JPG WERE SET UP IN MAIN.
RR=0
IF(JP.GT.1)GO TO 611
IF(NAMX.EQ.NAMZ)GO TO 611
RS=6
RR=SPG
C FOR SPACER ON STAFF 0
611 CALL STAFF(RS,HX,RZ,RHGT(JP),RPSZ(JP),RZ,RZ,RR)
HX=JPG
RS=4.
RT=0
CALL STAFF(2.,RS,RZ,HX,RZ,RZ,RZ,RZ)
IF(BRACK.NE.0)CALL STAFF(5.,RS,RZ,HX,RZ,RZ,BRACK,RZ)
RT=RX
GO TO 511
411 CALL STAFF(RS,8.,0,HGT,RSTJ2,0,0,SP)
HGT=HGT-HX
511 IF(XLINE.EQ.ZLINE)GO TO 33
IF(JEND)GO TO 60
C FOR PREMATURE PAGE END
IF(K.NE.I)GO TO 6
IF(RT.EQ.0)GO TO 6
60 IF(IPG.EQ.0)GO TO 6
RX=RT
RT=0
CALL STAFF(6.,8.,0,0,0,0,1.,SP)
C PUTS IN SPACER
RT=RX
6 IF(JSLUR.EQ.0)GO TO 2333
CC LL=JSLUR
CC JSLUR=0
CALL JSL(JSLUR)
1333 CALL STAFF(5.,5.,0,Q(LL),Q(LL+1),SLSP,Q(LL+3),0)
2333 IF(JSL2.EQ.0)GO TO 333
CC LL=JSL2
C FOR 2ND SLUR AT END OF LINE.
CC JSL2=0
CALL JSL(JSL2)
GO TO 1333
333 IF(CLEF.EQ.-99)GO TO 33
C ONLY STAFF FOR FIRST LINE AT TOP.
RX=10.*RSTJ2
C THE SPACER
LA=0
IF(IPG)GO TO 3011
LA=JPG
3111 RT=RSTNUM(LA)
LL=RT
CLEF=RCLEF(LL)
C GETS CLEF FOR PAGE LAYOUT, RT IS STAFF# IN CALL
LA=LA-1
3011 CALL STAFF(3.,3.,1.5,0,CLEF,0,0,0)
IF(SIG.EQ.-99)GO TO 3211
RS=4.
R5=SIG
CC RX=CLEF
CC IF(R5.LT.50)GO TO 332
CC RX=IFIX((R5+50.)/100.)
CC R5=R5-RX*100.
C CLEF+SIG
332 CALL STAFF(RS,17.,11.0*RSTJ2,0,R5,CLEF,0,0)
RX=12.*RSTJ2
3211 IF(LA.GT.0)GO TO 3111
33 R4=RA
R5=Q(N+3)
RS=0
R7=RT
R8=RX
R9=200.
LL=0
L=K-J+1
CALL PTMOVE(Q,KPN(J))
RA=R5
31 IF(MTR1)GO TO 231
LA=0
IF(IPG)GO TO 5011
LA=JPG
5111 RT=RSTNUM(LA)
C PUT METER ON ALL STAVES FOR PAGE LAYOUT
LA=LA-1
5011 R=200.0+2.23*RSTJ2
CALL STAFF(Q(MTR1),Q(MTR1+1),R,0,Q(MTR1+5),Q(MTR1+6),0,0)
C PUTS METER AFTER END OF STAFF
IF(MTR2)GO TO 5211
R=200.0+6.7*RSTJ2
CALL STAFF(Q(MTR2),Q(MTR2+1),R,0,Q(MTR2+5),Q(MTR2+6),0,0)
C PUTS COMPOSITE METER AFTER END OF STAFF
5211 IF(LA.GT.0)GO TO 5111
231 KB=KL
131 DO 30 NA=KK,K
KWDS(KP)=KB
KP=KP+1
JK=KPN(NA)
R=Q(JK+1)
IF(R.EQ.5)GO TO 135
IF(R.NE.44)GO TO 35
135 RR=Q(JK+6)
IF(RR.LT.Q(JK+3))GO TO 635
C NEEDED WHEN DATA ON LINE HAS BEEN EXPANDED, NOT CONTRACTED.
IF(RR.LT.199.)GO TO 37
C CATCHES END OF SLUR AND VARIOUS LINES
635 IF(R.NE.5)GO TO 37
C TO PUT SLUR ON NEXT LINE.
C*********** IS SOMETHING MISSING HERE???????? 4/76
235 IF(JSLUR.NE.0)GO TO 435
CC JSLUR=JK+4
JSLUR=JSLX(JK)
GO TO 535
CC435 JSL2=JK+4
435 JSL2=JSLX(JK)
C FOR 2ND SLUR
535 RR=201
IF(Q(JK+8).LT.-1)RR=202
Q(JK+6)=RR
IF(R.EQ.5)GO TO 30
GO TO 38
35 IF(R.NE.2)GO TO 36
IF(Q(JK).LT.6.)GO TO 30
RR=RIGHT(NA,-1)
IF(RR.GE.199.)RR=RX
Q(JK+3)=RR-1.6*RSTJ2+(RIGHT(NA,1)-RR)/2.
C FUNCTION 'RIGHT' FINDS RIGHT ITEMS FOR CENTERING.
C CENTERS WHOLE REST
GO TO 30
36 IF(R.NE.3)GO TO 34
CC RR=Q(JK+5)
CC IF(Q(JK).LT.3)RR=0
CC CLEF=AMOD(RR,100.0)
CLEF=CLEFN(Q,JK)
IF(IPG)GO TO 30
LL=Q(JK+2)
C GETS CLEF FOR PAGE LAYOUT
RCLEF(LL)=CLEF
GO TO 30
34 IF(R.NE.17)GO TO 37
SIG=Q(JK+5)
IF(ABS(SIG).GT.100.)SIG=-99
C DO NOT REPEAT KSIG MADE UP OF NATURALS.
CXX IF(Q(JK).GT.3)SIG=SIG+Q(JK+6)*100.
CXX CLEF # IN P6 WITH KEY SIGS.
C NEXT CHANGES CODE NUM BACK TO ORIGINAL
37 IF(R.LT.33)GO TO 30
38 Q(JK+1)=R/11.
30 KB=KPN(NA+1)-KPN(NA)+KB
CALL PSHFT(KK,K)
RS=RT
LL='J'
R4=0
R5=200
NA=L
L=KP-JJ
CALL PTMOVE(RN,KWDS(JJ))
DO 47 JJ2=JJ,KP
LL=KWDS(JJ2)
AA=RN(LL+1)
IF(AA.NE.10.AND.AA.NE.16)GO TO 347
DO 147 NN=JJ2+1,KP
MM=KWDS(NN)
IF(RN(MM+1).NE.16)GO TO 147
C FOUND THE NEXT TEXT AFTER TEXT OR NUMB.
IF(RN(MM).EQ.8)GO TO 47
C JUMP IF POS. IS ALREADY TAKEN CARE OF.
IF(AA.EQ.10)GO TO 247
C NEXT FOR TEXT FOLLOWING TEXT
IF(ABS(RN(MM+4)-RN(LL+4)).GE.4)GO TO 47
C JUMP IF ON DIFF. VERT. PLANE.
AA=(RN(LL+9)+4.)*RSTJ2*RN(LL+5)+RN(LL+3)
C SETS MINIMUM SPACE.
IF(RN(MM+3).LT.AA)RN(MM+3)=AA
GO TO 47
247 IF(ABS(RN(MM+4)-RN(LL+4)).GT.6)GO TO 47
C CHECKS VERT. POS.
AA=RN(LL+4)+7
IF(RN(MM+4)-AA.LT.0)RN(MM+4)=AA
C MOVE WORD TO RIGHT OF NUMBER IF IT WAS TOO CLOSE
GO TO 47
147 CONTINUE
GO TO 47
347 IF(AA.NE.5)GO TO 1047
C TO IMPROVE SLUR PARAMETERS
R8=RN(LL+8)
IF(RN(LL).LT.6)R8=0
IF(R8.GT.0)GO TO 47
C JUMP IF A BRACKET
R=RN(LL+6)
DO 647 NN=JJ2+1,KP
MM=KWDS(NN)
C THIS IS TO FIND SLURS AT END OF OLD LINES AND EXTEND THEM
IF(RN(MM+1).NE.4)GO TO 647
C FIND A BAR LINE
IF(RN(MM+3).GT.199.)GO TO 647
C IGNORE LAST BAR OR LINE.
IF(RN(MM).GT.2)GO TO 647
AA=ABS(RN(MM+3)-R)
IF(AA.GT.1.)GO TO 647
RN(LL+6)=R+4
GO TO 47
647 CONTINUE
R7=RN(LL+7)
R9=R-RN(LL+3)+(R8+1.)*2.
IF(R9.GT.7)GO TO 47
C NO WORK NEEDED. IT'S LONG ENOUGH
IF(RN(LL).GT.5)RN(LL+8)=-1
R=1.
IF(R7.LT.0)R=-R
547 RN(LL+4)=RN(LL+4)+R
RN(LL+5)=RN(LL+5)+R
C WERE +AA ↑↑↑↑↑
RN(LL+7)=R
GO TO 47
1047 IF(AA.NE.6)GO TO 47
IF(RN(LL).LT.7)GO TO 47
IF(RN(LL+9).GT.200.)RN(LL+9)=0
C ********** FIX THIS IN GETPTS, MOVER. IT SHOULDN'T MOVE P9 ALWAYS.
47 CONTINUE
IF(K.EQ.I)GO TO 2
L=NA
J=K+1
C SO IT DOESN'T GO THRU ALL DATA
RT=RT-1
XLINE=RA+ZLINE
IF(ENDLN-XLINE.LT.80.)XLINE=ENDLN
IF(IPG.EQ.0)GO TO 2
C OMIT NEXT FOR PAGE LAYOUT ONLY
10 IF(KL.GT.1700.OR.KP.GT.190.OR.RT.OR.JEND)GO TO 2
1 IF(K.EQ.I)GO TO 3
2 KWDS(KP)=KB
J=1
JJ2=KP+1
JPQ=KB
C WRITES 1 EXTRA WORD
CALL PUTFIL(NAMX)
LCNT=0
NDPY=0
CALL FASTOU(RSTFAC,128)
CALL FASTOU(KWDS,JJ2)
CALL FASTOU(RN,JPQ)
TYPE 101,NAMX
IF(KK.GE.I)CALL EXIT
NAMX=NAMX+2
IF(IPG)GO TO 6011
NPG=NPG+1
IF(NPG.LE.MPG)GO TO 6011
NPG=1
C RESET, UPDATE FILENAMES
NAMX=NAMZ+256
NAMZ=NAMX
6011 NAMQ=NAMX
CALL FINFIL
GO TO 100
101 FORMAT(1XA5)
END